# audit::audit --
#
#	Tcl code logging and auditing utility.
#
#	This package utilities to log events that happen in an
#	application
#

# audit levels:
#	1	error
#	2	warning
#	3	notice
#	4	debug
#	5	application logic
#	6	major backend operations
#	7	minor backend operations
#	8	verbose operation (like database)
#	9	stack trace level

package require msgcat

namespace eval ::audit {}
namespace eval ::audit::audit {}

set audit::auditLevels [list \
    [msgcat::mc "Audit level 0 - disabled"] \
    [msgcat::mc "Audit level 1 - error information"] \
    [msgcat::mc "Audit level 2 - warning information"] \
    [msgcat::mc "Audit level 3 - notice information"] \
    [msgcat::mc "Audit level 4 - debug information"] \
    [msgcat::mc "Audit level 5 - application logic"] \
    [msgcat::mc "Audit level 6 - major backend operations"] \
    [msgcat::mc "Audit level 7 - minor backend operations"] \
    [msgcat::mc "Audit level 8 - verbose operations"] \
    [msgcat::mc "Audit level 9 - stack trace"] \
    ]

if {![info exists ::audit::audit::notifiers]} {
    set ::audit::audit::notifiers [list]
}

proc ::audit::audit::init {} {
    variable logdata
    if {![info exists logdata]} {
	set logdata [list]
    }
    set ::audit::audit::options(INIT) 1
    set ::audit::audit::options(DUMPIDLEVERSION) 0
    set ::audit::audit::options(DUMPDATAVERSION) 0
    
    set ::audit::audit::options(-limit) 20000
    set ::audit::audit::options(-level) 0
    set ::audit::audit::options(-logfile) ""
    set ::audit::audit::options(-emptylog) true
    set ::audit::audit::options(-logfilecount) 10
    set ::audit::audit::options(-stderr) false
    set ::audit::audit::options(-synclog) true
    set ::audit::audit::options(-datafile) ""
    set ::audit::audit::options(-datafilecount) 1

    reconfigureFunctions

    set ei $::errorInfo
    set ec $::errorCode
    if {([info commands ::zlib] != "") || (![catch {load "" zlib}])} {
	rename ::audit::audit::decompressZlib ::audit::audit::decompress
	rename ::audit::audit::decompressTrf {}
	rename ::audit::audit::compressZlib ::audit::audit::compress
	rename ::audit::audit::compressTrf {}
    }  elseif {([info commands ::zip] != "") || (![catch {package require Trf}])} {
	rename ::audit::audit::decompressZlib {}
	rename ::audit::audit::decompressTrf ::audit::audit::decompress
	rename ::audit::audit::compressZlib {}
	rename ::audit::audit::compressTrf ::audit::audit::compress
    }  else  {
	rename ::audit::audit::decompressZlib {}
	rename ::audit::audit::decompressTrf {}
	rename ::audit::audit::compressZlib {}
	rename ::audit::audit::compressTrf {}
    }
    set ::errorInfo $ei
    set ::errorCode $ec
    return ""
}

proc ::audit::audit::reconfigureFunctions {} {
    variable options
    after cancel ::audit::audit::idleDump
    if {$options(-level) > 0} {
	proc ::audit::audit {type level message {varlist ""} args} {
	    uplevel [list ::audit::audit::audit $type $level $message $varlist $args]
	}

	# auditing procedure calls
	if {$options(-level) >= 9} {
	    proc ::audit::auditEnter {type} {uplevel [list ::audit::audit::audit Enter 9 "[uplevel {info level}]: Entering [uplevel {lindex [info level [info level]] 0}]" [uplevel {info locals}] {}]}
	    proc ::audit::auditExit {type} {uplevel [list ::audit::audit::audit Exit 9 "[uplevel {info level}]: Exiting [uplevel {lindex [info level [info level]] 0}]" "" {}]}
	}  else  {
	    proc ::audit::auditEnter {type} {}
	    proc ::audit::auditExit {type} {}
	}

	incr options(DUMPDATAVERSION)
	idleDump
    }  else  {
	proc ::audit::audit {type level message {varlist ""} args} {}
	proc ::audit::auditEnter {type} {}
	proc ::audit::auditExit {type} {}
    }
}

proc ::audit::audit::saveAudit {filename} {
    variable logdata
    dumpData $filename 1 $logdata
}

proc ::audit::audit::idleDump {} {
    variable options
    variable logdata
    if {$options(DUMPIDLEVERSION) != $options(DUMPDATAVERSION)} {
	set options(DUMPIDLEVERSION) $options(DUMPDATAVERSION)

	if {($options(-logfile) != "") && (!$options(-synclog))} {
	    dumpLogfile $options(-logfile) $logdata
	}

	if {$options(-datafile) != ""} {
	    dumpData $options(-datafile) 1 $logdata
	}
    }

    after 1000 ::audit::audit::idleDump
}

proc ::audit::logroll {} {
    logrollLog
    logrollData
}
proc ::audit::logrollLog {} {
    set count [expr {$::audit::audit::options(-logfilecount) - 1}]
    if {$count < 0} {
	file delete $::audit::audit::options(-logfile)
	return
    }  elseif {$count > 0} {
	set filename [format %s.%03d $::audit::audit::options(-logfile) $count]
	if {[file exists $filename]} {
	    file delete $filename
	}
	for {set i [expr {$count - 1}]} {$i >= 0} {incr i -1} {
	    set in [expr {$i + 1}]
	    set old [format %s.%03d $::audit::audit::options(-logfile) $i]
	    set new [format %s.%03d $::audit::audit::options(-logfile) $in]
	    if {[file exists $old]} {
		file rename $old $new
	    }
	}
	if {![file exists $::audit::audit::options(-logfile)]} {
	    set fh [open $::audit::audit::options(-logfile) w]
	    close $fh
	}
	file rename $::audit::audit::options(-logfile) $::audit::audit::options(-logfile).000
    }
}

proc ::audit::logrollData {} {
    set count [expr {$::audit::audit::options(-datafilecount) - 1}]
    if {$count < 0} {
	file delete $::audit::audit::options(-datafile)
	return
    }  elseif {$count > 0} {
	set filename [format %s.%03d $::audit::audit::options(-datafile) $count]
	if {[file exists $filename]} {
	    file delete $filename
	}
	for {set i [expr {$count - 1}]} {$i >= 0} {incr i -1} {
	    set in [expr {$i + 1}]
	    set old [format %s.%03d $::audit::audit::options(-datafile) $i]
	    set new [format %s.%03d $::audit::audit::options(-datafile) $in]
	    if {[file exists $old]} {
		file rename $old $new
	    }
	}
	if {[file exists $::audit::audit::options(-datafile)]} {
	    file rename $::audit::audit::options(-datafile) $::audit::audit::options(-datafile).000
	}
    }
}

proc ::audit::addNotifier {command {priority 0}} {
    upvar #0 ::audit::audit::notifiers notifiers
    set notifiers [lsort -index 1 -decreasing -integer \
	[lsort -unique -index 0 [linsert $notifiers end [list $command $priority]]]]
}

proc ::audit::removeNotifier {command} {
    upvar #0 ::audit::audit::notifiers notifiers
    set n [list]
    foreach ne $notifiers {
	if {[lindex $ne 0] != $command} {
	    lappend n $ne
	}
    }
    set notifiers $n
}

proc ::audit::cget {n} {
    return $::audit::audit::options($n)
}

proc ::audit::configure {args} {
    if {[llength $args] == 0} {
	set rc [list]
	foreach n [lsort [array names ::audit::audit::options -*]] {
	    lappend rc [list $n $::audit::audit::options($n)]
	}
	return $rc
    }
    if {[llength $args] == 1} {
	set n [lindex $args 0]
	return [list $n $::audit::audit::options($n)]
    }

    if {([llength $args] % 2) != 0} {
	set ei "Need to supply name-value pairs."
	return -code error -errorinfo $ei $ei
    }

    set names [join [lsort [array names ::audit::audit::options -*]] ", "]

    set oldlogfile $::audit::audit::options(-logfile)
    set olddatafile $::audit::audit::options(-datafile)

    foreach {n v} $args {
	if {![info exists ::audit::audit::options($n)] || ([string index $n 0] != "-")} {
	    set ei "Unknown option \"$n\": should be one of $names."
	    return -code error -errorinfo $ei $ei
	}
	set ::audit::audit::options($n) $v
    }

    if {($oldlogfile != $::audit::audit::options(-logfile)) && ($::audit::audit::options(-logfile) != "")} {
	if {$::audit::audit::options(-emptylog)} {
	    set fh [open $::audit::audit::options(-logfile) w]
	}  else  {
	    set fh [open $::audit::audit::options(-logfile) a]
	}
	close $fh
    }

    if {($olddatafile != $::audit::audit::options(-datafile)) && ($::audit::audit::options(-datafile) != "")} {
	set fh [open $::audit::audit::options(-datafile) w]
	close $fh
    }

    audit::reconfigureFunctions
    return ""
}

proc audit::getlog {{maxlevel ""} {re_name ""} {maxlength ""}} {
    set cmd ""
    set idx [expr {[llength $::audit::audit::logdata]-1}]

    set rc [list]

    append cmd "set ld \[lindex \$::audit::audit::logdata \$idx\]" \n

    if {[string is integer -strict $maxlevel]} {
	append cmd "if \{\[lindex \$ld 3\] > $maxlevel\} \{continue\}" \n
    }

    if {$re_name != ""} {
	append cmd "if \{!\[regexp [list $re_name] \[lindex \$ld 2\]\]\} \{continue\}" \n
    }

    append cmd "set rc \[linsert \$rc 0 \$ld\]" \n
    if {[string is integer -strict $maxlength]} {
	append cmd "if \{\[llength \$rc\] >= $maxlength\} \{break\}" \n
    }

    for {} {$idx >= 0} {incr idx -1} $cmd

    return $rc
}

proc ::audit::saveAudit {filename} {
    ::audit::audit::saveAudit $filename
}

proc audit::audit::audit {type level message varlist ar {notifiers true}} {
    variable options
    variable logdata

    if {$level > $options(-level)} {
	return
    }

    set ei $::errorInfo
    set ec $::errorCode

    # avoid seconds changing
    # STRANGE - they do change anyway
    while {true} {
	set clk [clock seconds]
	set cm [clock clicks -milliseconds]
	set clk1 [clock seconds]
	if {$clk == $clk1} {break}
    }

    set vars [list]
    foreach var $varlist {
	upvar $var varval
	if {[catch {
	    set v $varval
	    lappend vars $var value $v
	}]} {
	    set an [array names varval]
	    set v [list]
	    if {[llength $an] > 0} {
		foreach n [lsort $an] {
		    catch {
			lappend v $varval($n)
		    }
		}
	    }
	    lappend vars $var array $v
	}
    }

    set en [list $clk [expr {$cm % 10000}] $type $level $message $vars $ar [lrange [doStackTrace] 2 end]]
    incr options(DUMPDATAVERSION)
    lappend logdata $en
    if {($options(-limit) > 0) && ([llength $logdata] > $options(-limit))} {
	set logdata [lrange $logdata end-[expr {$options(-limit)-1}] end]
    }

    if {($options(-logfile) != "") && ($options(-synclog))} {
	set msg [formatMessage $en]
	catch {
	    set fh [open $options(-logfile) a]
	    fconfigure $fh -encoding utf-8
	    puts $fh $msg
	    close $fh
	}
        if {$options(-stderr)} {
	    catch {puts stderr $msg}
	}
    }  else  {
        if {$options(-stderr)} {
	    set msg [formatMessage $en]
	    catch {puts stderr $msg}
	}
    }

    # notifiers
    foreach n $::audit::audit::notifiers {
	if {[catch [lindex $n 0] rc]} {
	    audit::audit::audit audit 1 "Error while calling notifier: $rc" [list errorInfo $::errorInfo] [list] false
	}
    }
    set ::errorInfo $ei
    set ::errorCode $ec
    return ""
}


# logging
proc audit::audit::formatMessage {msg} {
    foreach {clk cm type level message vars ar stacktrace} $msg break
    return "[clock format $clk -format {%y-%m-%d %H:%M:%S}].[format %04d $cm] | $type | $level | [llength $stacktrace] | $message"
}

proc audit::saveAudit {filename} {
    ::audit::audit::dumpData $filename true $::audit::audit::logdata
}

proc audit::audit::dumpLogfile {filename logdata} {
    set str ""
    foreach msg $logdata {
	append str [formatMessage $msg] \n
    }
    set fh [open $filename w]
    fconfigure $fh -encoding utf-8
    puts $fh $str
    close $fh
}

proc audit::audit::dumpData {filename compress logdata} {
    if {$compress} {
	set data "AUDIT.DUMP\n[compress [encoding convertto utf-8 $logdata] 4]"
    }  else  {
	set data "AUDIT.RAW\n[encoding convertto utf-8 $logdata]"
    }
    set fh [open $filename w]
    fconfigure $fh -translation binary
    puts -nonewline $fh $data
    close $fh
}

# audit::audit::doStackTrace --
#
#	Creates stack traces up to current stack level.
#	Used in other audit procedures to store the stack trace.
#
#
proc audit::audit::doStackTrace {} {
    set rc [list]
    set i 0
    set err 0
    set ei $::errorInfo
    set ec $::errorCode
    while {$err < 3} {
	if {[catch {
	    lappend rc [info level $i]
	}]} {
	    lappend rc {}
	    incr err
	}  else  {
	    set err 0
	}
	incr i -1
    }
    while {[llength $rc] > 0} {
	if {[lindex $rc end] == {}} {
	    set rc [lrange $rc 0 end-1]
	}  else  {
	    break
	}
    }
    set ::errorInfo $ei
    set ::errorCode $ec
    return $rc
}

#
# compression
#
# choosing the right proc is done by init
#
proc ::audit::audit::compressTrf {data level} {
    return [zip -mode compress -level $level $data]
}

proc ::audit::audit::compressZlib {data level} {
    return [zlib compress $data $level]
}

proc ::audit::audit::decompressTrf {data} {
    return [zip -mode decompress $data]
}

proc ::audit::audit::decompressZlib {data} {
    return [zlib decompress $data]
}

if {![info exists ::audit::audit::options(INIT)]} {
    ::audit::audit::init
}

package provide audit::audit 1.3

